home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0191.ZIP / PFORMAT.PAS < prev    next >
Pascal/Delphi Source File  |  1985-02-03  |  27KB  |  965 lines
  1. PROGRAM pFormat (INPUT, OUTPUT);
  2. {
  3.   AUTHOR:  andy j s decepida
  4.            16 Nov 1984
  5.  
  6.   DESCRIPTION: Reads in a .PAS text file and, depending on the user's
  7.                choice/s, generates a copy with alterations in the case of
  8.                the contained text.
  9. }
  10.  
  11. CONST
  12.   Array_Size  =  177;
  13.  
  14. TYPE
  15.   Answer_Set  =  SET OF CHAR;
  16.  
  17.   Cursor_Size =  (Full, Half, Minimum, Invisible);
  18.  
  19.   Global_Strg =  STRING[255];
  20.  
  21.   Case_Types  =  (Upper,
  22.                  Lower,
  23.                  AsIs);
  24.  
  25. VAR
  26.   IO_Template,
  27.   Work_Template,
  28.   Proc_Label,
  29.   Mask,
  30.   Temp,
  31.   Temp_String,
  32.   In_File_Name,
  33.   Out_File_Name : Global_Strg;
  34.  
  35.   Text_File,
  36.   Pretty_Output : TEXT;
  37.  
  38.   Token         : ARRAY [1..Array_Size] OF STRING[20];
  39.  
  40.   Res_Case,
  41.   Non_Res_Case  : Case_Types;
  42.  
  43.   Strt,
  44.   Endd,
  45.   Indx,
  46.   Token_Locn,
  47.   Len,
  48.   Cnt           : INTEGER;
  49.  
  50.   CD_Char,
  51.   Prior,
  52.   Next          : CHAR;
  53.  
  54.   Borland_Convention,
  55.   Interruptable,
  56.   Comment_Active,
  57.   Ok            : BOOLEAN;
  58.  
  59. {*****************************************************************************}
  60.  
  61.   PROCEDURE Init_Array;
  62.   {
  63.     initialize the reserved word array
  64.  
  65.   Warning: because the primitive parsing method employed here centred
  66.   crucially on this array it is NOT recommended that you alter the
  67.   contents and sequence of the entries.  My apologies non MS-DOS users
  68.   for not including the reserved words that their TurboPascal editions do
  69.   support.  Should you, as say as CP/M Turbo programmer, wish to alter
  70.   this table keep in mind two things:
  71.  
  72.  
  73.   ■ Do_Turbo_Extension uses the index (INDX) corresponding to the table
  74.     entry of a found reserved word to assign the Borland type setting style
  75.     to the output substring ... ergo, keep the new array indices in synch
  76.     with the CASE selectors in Do_Turbo_Extension.
  77.  
  78.   ■ Since pFORMAT sequentially steps through this array to find a corresponding
  79.     pattern occurrences in the text line currently being processed, it
  80.     becomes important to keep the shorter reserved words that are embedded in
  81.     other, longer reserved words as substrings towards the bottom of the
  82.     array!
  83. }
  84.   BEGIN {Init_Array}
  85.     Token [  1] := 'ABSOLUTE';
  86.     Token [  2] := 'ARCTAN';
  87.     Token [  3] := 'ASSIGN';
  88.     Token [  4] := 'AUXINPTR';
  89.     Token [  5] := 'AUXOUTPTR';
  90.     Token [  6] := 'BLOCKREAD';
  91.     Token [  7] := 'BLOCKWRITE';
  92.     Token [  8] := 'BOOLEAN';
  93.     Token [  9] := 'BUFLEN';
  94.     Token [ 10] := 'CLREOL';
  95.     Token [ 11] := 'CLRSCR';
  96.     Token [ 12] := 'CONCAT';
  97.     Token [ 13] := 'CONINPTR';
  98.     Token [ 14] := 'CONOUTPTR';
  99.     Token [ 15] := 'CONSTPTR';
  100.     Token [ 16] := 'CRTEXIT';
  101.     Token [ 17] := 'CRTINIT';
  102.     Token [ 18] := 'DELETE';
  103.     Token [ 19] := 'DELLINE';
  104.     Token [ 20] := 'DOWNTO';
  105.     Token [ 21] := 'EXECUTE';
  106.     Token [ 22] := 'EXTERNAL';
  107.     Token [ 23] := 'FILEPOS';
  108.     Token [ 24] := 'FILESIZE';
  109.     Token [ 25] := 'FILLCHAR';
  110.     Token [ 26] := 'FORWARD';
  111.     Token [ 27] := 'FREEMEM';
  112.     Token [ 28] := 'FUNCTION';
  113.     Token [ 29] := 'GETMEM';
  114.     Token [ 30] := 'GOTOXY';
  115.     Token [ 31] := 'GRAPHBACKGROUND';
  116.     Token [ 32] := 'GRAPHCOLORMODE';
  117.     Token [ 33] := 'GRAPHMODE';
  118.     Token [ 34] := 'GRAPHWINDOW';
  119.     Token [ 35] := 'HEAPSTR';
  120.     Token [ 36] := 'HIRESCOLOR';
  121.     Token [ 37] := 'INLINE';
  122.     Token [ 38] := 'INSERT';
  123.     Token [ 39] := 'INSLINE';
  124.     Token [ 40] := 'INTEGER';
  125.     Token [ 41] := 'IORESULT';
  126.     Token [ 42] := 'KEYPRESSED';
  127.     Token [ 43] := 'LENGTH';
  128.     Token [ 44] := 'LONGFILEPOS';
  129.     Token [ 45] := 'LONGFILESIZE';
  130.     Token [ 46] := 'LONGSEEK';
  131.     Token [ 47] := 'LOWVIDEO';
  132.     Token [ 48] := 'LSTOUTPTR';
  133.     Token [ 49] := 'MAXAVAIL';
  134.     Token [ 50] := 'MAXINT';
  135.     Token [ 51] := 'MEMAVAIL';
  136.     Token [ 52] := 'NORMVIDEO';
  137.     Token [ 53] := 'NOSOUND';
  138.     Token [ 54] := 'OUTPUT';
  139.     Token [ 55] := 'PACKED';
  140.     Token [ 56] := 'PALETTE';
  141.     Token [ 57] := 'PROCEDURE';
  142.     Token [ 58] := 'PROGRAM';
  143.     Token [ 59] := 'RANDOMIZE';
  144.     Token [ 60] := 'RANDOM';
  145.     Token [ 61] := 'READLN';
  146.     Token [ 62] := 'RECORD';
  147.     Token [ 63] := 'RELEASE';
  148.     Token [ 64] := 'RENAME';
  149.     Token [ 65] := 'REPEAT';
  150.     Token [ 66] := 'REWRITE';
  151.     Token [ 67] := 'SIZEOF';
  152.     Token [ 68] := 'STRING';
  153.     Token [ 69] := 'TEXTBACKGROUND';
  154.     Token [ 70] := 'TEXTCOLOR';
  155.     Token [ 71] := 'TEXTMODE';
  156.     Token [ 72] := 'UPCASE';
  157.     Token [ 73] := 'USRINPTR';
  158.     Token [ 74] := 'USROUTPTR';
  159.     Token [ 75] := 'WHEREX';
  160.     Token [ 76] := 'WHEREY';
  161.     Token [ 77] := 'WINDOW';
  162.     Token [ 78] := 'WRITELN';
  163.     Token [ 79] := 'ARRAY';
  164.     Token [ 80] := 'BEGIN';
  165.     Token [ 81] := 'CHAIN';
  166.     Token [ 82] := 'CLOSE';
  167.     Token [ 83] := 'CONST';
  168.     Token [ 84] := 'DELAY';
  169.     Token [ 85] := 'ERASE';
  170.     Token [ 86] := 'FALSE';
  171.     Token [ 87] := 'FLUSH';
  172.     Token [ 88] := 'HIRES';
  173.     Token [ 89] := 'INPUT';
  174.     Token [ 90] := 'LABEL';
  175.     Token [ 91] := 'MSDOS';
  176.     Token [ 92] := 'PORTW';
  177.     Token [ 93] := 'RESET';
  178.     Token [ 94] := 'ROUND';
  179.     Token [ 95] := 'SOUND';
  180.     Token [ 96] := 'TRUNC';
  181.     Token [ 97] := 'UNTIL';
  182.     Token [ 98] := 'WHILE';
  183.     Token [ 99] := 'WRITE';
  184.     Token [100] := 'ADDR';
  185.     Token [101] := 'BYTE';
  186.     Token [102] := 'CASE';
  187.     Token [103] := 'CHAR';
  188.     Token [104] := 'COPY';
  189.     Token [105] := 'CSEG';
  190.     Token [106] := 'DRAW';
  191.     Token [107] := 'DSEG';
  192.     Token [108] := 'ELSE';
  193.     Token [109] := 'EOLN';
  194.     Token [110] := 'FILE';
  195.     Token [111] := 'FRAC';
  196.     Token [112] := 'GOTO';
  197.     Token [113] := 'HALT';
  198.     Token [114] := 'INTR';
  199.     Token [115] := 'MARK';
  200.     Token [116] := 'MEMW';
  201.     Token [117] := 'MOVE';
  202.     Token [118] := 'PLOT';
  203.     Token [119] := 'PORT';
  204.     Token [120] := 'PRED';
  205.     Token [121] := 'READ';
  206.     Token [122] := 'REAL';
  207.     Token [123] := 'SEEK';
  208.     Token [124] := 'SQRT';
  209.     Token [125] := 'SSEG';
  210.     Token [126] := 'SUCC';
  211.     Token [127] := 'SWAP';
  212.     Token [128] := 'TEXT';
  213.     Token [129] := 'THEN';
  214.     Token [130] := 'TRUE';
  215.     Token [131] := 'TYPE';
  216.     Token [132] := 'WITH';
  217.     Token [133] := 'AND';
  218.     Token [134] := 'AUX';
  219.     Token [135] := 'CHR';
  220.     Token [136] := 'CON';
  221.     Token [137] := 'COS';
  222.     Token [138] := 'DIV';
  223.     Token [139] := 'END';
  224.     Token [140] := 'EOF';
  225.     Token [141] := 'EXP';
  226.     Token [142] := 'FOR';
  227.     Token [143] := 'INT';
  228.     Token [144] := 'KBD';
  229.     Token [145] := 'LST';
  230.     Token [146] := 'MEM';
  231.     Token [147] := 'MOD';
  232.     Token [148] := 'NEW';
  233.     Token [149] := 'NIL';
  234.     Token [150] := 'NOT';
  235.     Token [151] := 'ODD';
  236.     Token [152] := 'OFS';
  237.     Token [153] := 'ORD';
  238.     Token [154] := 'POS';
  239.     Token [155] := 'PTR';
  240.     Token [156] := 'SEG';
  241.     Token [157] := 'SET';
  242.     Token [158] := 'SHL';
  243.     Token [159] := 'SHR';
  244.     Token [160] := 'SIN';
  245.     Token [161] := 'SQR';
  246.     Token [162] := 'STR';
  247.     Token [163] := 'TRM';
  248.     Token [164] := 'USR';
  249.     Token [165] := 'VAL';
  250.     Token [166] := 'VAR';
  251.     Token [167] := 'XOR';
  252.     Token [168] := 'DO';
  253.     Token [169] := 'HI';
  254.     Token [170] := 'IF';
  255.     Token [171] := 'IN';
  256.     Token [172] := 'LN';
  257.     Token [173] := 'LO';
  258.     Token [174] := 'OF';
  259.     Token [175] := 'OR';
  260.     Token [176] := 'PI';
  261.     Token [177] := 'TO';
  262.   END;  {Init_Array}
  263.  
  264. {*****************************************************************************}
  265.  
  266.   PROCEDURE Set_Cursor (Size : Cursor_Size);
  267.   {
  268.     cursor is set according to the passed Size ... IBM-PC specific!
  269.   }
  270.  
  271.   TYPE
  272.     Reg_Pack    =  RECORD
  273.                     AX, BX, CX, DX, BP, SI, DI, ES, Flags : INTEGER;
  274.     END; {of Reg_Pack}
  275.  
  276.   VAR
  277.     Rec_Pack    :  Reg_Pack;
  278.  
  279.   BEGIN
  280.     Rec_Pack.AX := $0100;     {set cursor type service code ... cf A-47 of
  281.                               Hardware Technical Reference Manual}
  282.     CASE Size OF
  283.       Full     : Rec_Pack.CX := $000D;
  284.       Half     : Rec_Pack.CX := $070C;
  285.       Minimum  : Rec_Pack.CX := $0B0C;
  286.       Invisible: Rec_Pack.CX := $2000;
  287.     END; {CASE Size OF}
  288.  
  289.     Intr ($10, Rec_Pack)      {call video I/O ROM call}
  290.   END;
  291.  
  292. {*****************************************************************************}
  293.  
  294.   FUNCTION Is_Special_Char (Ch : CHAR) : BOOLEAN;
  295.   {
  296.     TRUE if Ch is a special char
  297.   }
  298.  
  299.   BEGIN
  300.     Is_Special_Char := (ORD(Ch) IN [32, 39..47, 58..62, 91, 93, 123, 125])
  301.   END;
  302.  
  303. {*****************************************************************************}
  304.  
  305.   FUNCTION Lo_Case (Ch : CHAR) : CHAR;
  306.   {
  307.     returns lower case of an alpha char
  308.   }
  309.  
  310.   BEGIN
  311.     IF (Ch IN ['A'..'Z']) THEN
  312.       Ch := CHR (ORD(Ch) - ORD('A') + ORD('a'));
  313.     Lo_Case := Ch
  314.   END;
  315.  
  316. {*****************************************************************************}
  317.  
  318.   PROCEDURE Up_Strg (VAR Strg : Global_Strg);
  319.  
  320.   VAR
  321.     Slot : INTEGER;
  322.  
  323.   BEGIN
  324.     IF (LENGTH(Strg) > 0) THEN
  325.       FOR Slot := 1 TO LENGTH(Strg) DO
  326.         Strg[Slot] := UpCase(Strg[Slot])
  327.   END;
  328.  
  329. {*****************************************************************************}
  330.  
  331.   PROCEDURE Lo_Strg (VAR Strg : Global_Strg);
  332.  
  333.   VAR
  334.     Slot : INTEGER;
  335.  
  336.   BEGIN
  337.     IF (LENGTH(Strg) > 0) THEN
  338.       FOR Slot := 1 TO LENGTH(Strg) DO
  339.         Strg[Slot] := Lo_Case(Strg[Slot])
  340.   END;
  341.  
  342. {*****************************************************************************}
  343.  
  344.   FUNCTION Get_Char (Legal_Commands : Answer_Set) : CHAR;
  345.   {
  346.     waits for a CHAR input belonging in Legal_Commands
  347.   }
  348.  
  349.   CONST
  350.     Bks = 8;
  351.  
  352.   VAR
  353.     Ch_In : CHAR;
  354.  
  355.   BEGIN
  356.     WRITE ('[ ]');
  357.     WRITE (CHR(Bks), CHR(Bks), ' ',CHR(Bks));
  358.     REPEAT
  359.       Set_Cursor (Full);
  360.       READ (KBD, Ch_In);
  361.       Ch_In := UpCase (Ch_In);
  362.       IF NOT (Ch_In IN Legal_Commands) THEN
  363.         BEGIN
  364.           Sound (8900);
  365.           Delay (10);
  366.           NoSound;
  367.           Sound (90);
  368.           Delay (30);
  369.           NoSound;
  370.         END;
  371.     UNTIL (Ch_In IN Legal_Commands);
  372.     Set_Cursor (Minimum);
  373.     Get_Char := Ch_In;
  374.   END;
  375.  
  376. {*****************************************************************************}
  377.  
  378.   FUNCTION User_Says_YES : BOOLEAN;
  379.   {
  380.     waits for a y/Y or n/N CHAR input
  381.   }
  382.  
  383.   VAR
  384.     Reply : CHAR;
  385.  
  386.   BEGIN
  387.     WRITE (' [y/n] ■ ');
  388.     User_Says_YES := (Get_Char(['Y','N']) = 'Y')
  389.   END;
  390.  
  391. {*****************************************************************************}
  392.  
  393.   PROCEDURE Trim_Off (VAR TempStr : Global_Strg);
  394.  
  395.   BEGIN
  396.     WHILE POS(' ', TempStr) = 1 DO
  397.       DELETE (TempStr, 1, 1);
  398.   END;
  399.  
  400. {*****************************************************************************}
  401.  
  402.   PROCEDURE User_Quits;
  403.  
  404.   BEGIN
  405.     Set_Cursor (Minimum);
  406.     CrtExit;
  407.     ClrScr;
  408.     HALT;
  409.   END;
  410.  
  411. {*****************************************************************************}
  412.  
  413.   PROCEDURE Evaluate_User_Choice (ConfirmationTail : Global_Strg;
  414.                                           Reserved : BOOLEAN);
  415.   BEGIN {Evaluate_User_Choice}
  416.     WRITELN;
  417.     WRITE (' You chose ');
  418.     TextColor (8); TextBackGround (7);
  419.     CASE CD_Char OF
  420.       'U' : BEGIN
  421.               WRITE ('Upper-case');
  422.               IF Reserved THEN
  423.                 Res_Case := Upper
  424.               ELSE
  425.                 Non_Res_Case := Upper
  426.             END;
  427.       'L' : BEGIN
  428.               WRITE ('Lower-case');
  429.               IF Reserved THEN
  430.                 Res_Case := Lower
  431.               ELSE
  432.                 Non_Res_Case := Lower
  433.              END;
  434.       'A' : BEGIN
  435.               WRITE ('As-Is');
  436.               IF Reserved THEN
  437.                 Res_Case := AsIs
  438.               ELSE
  439.                 Non_Res_Case := AsIs
  440.             END;
  441.       'B' : BEGIN
  442.               WRITE ('Borland type setting');
  443.               Borland_Convention := TRUE;
  444.             END;
  445.       'Q' : User_Quits;
  446.     END;
  447.     LowVideo;
  448.     WRITELN (' ',ConfirmationTail);
  449.     WRITE   (' Is this correct? ');
  450.   END; {Evaluate_User_Choice}
  451.  
  452. {*****************************************************************************}
  453.  
  454.    PROCEDURE Change_Defaults;
  455.  
  456.     BEGIN {Change_Defaults}
  457.       WRITELN;
  458.       REPEAT
  459.         WRITELN;
  460.         WRITELN;
  461.         WRITELN (' ■ PASCAL reserved words.');
  462.         WRITE   ('   Options are : U(pper-case, L(ower-case, A(s-Is, Q(uit');
  463.         CD_Char := Get_Char (['U','L','A','Q']);
  464.         Evaluate_User_Choice ('for the RESERVED words.', TRUE);
  465.       UNTIL User_Says_YES;
  466.  
  467.       WRITELN;
  468.       REPEAT
  469.         WRITELN;
  470.         WRITELN;
  471.         WRITELN (' ■ Turbo Pascal Extensions.');
  472.         WRITE   ('   Options are : U(pper, L(ower, As-Is, B(o',
  473.                  'rland type setting, Q(uit');
  474.         CD_Char := Get_Char (['U','L','A','B','Q']);
  475.         Evaluate_User_Choice ('for the Turbo Pascal Extensions.', TRUE);
  476.       UNTIL User_Says_Yes;
  477.  
  478.       WRITELN;
  479.       REPEAT
  480.         WRITELN;
  481.         WRITELN;
  482.         WRITELN (' ■ Non-Reserved Words.');
  483.         WRITE   ('   Options are : U(pper-case, L(ower-case, A(s-is, Q(uit');
  484.         CD_Char := Get_Char (['U','L','A','Q']);
  485.         Evaluate_User_Choice (' for the user defined identifiers.',
  486.                            FALSE);
  487.       UNTIL User_Says_YES;
  488.     END; {Change_Defaults}
  489.  
  490. {*****************************************************************************}
  491.  
  492.   FUNCTION Is_A_Token : BOOLEAN;
  493.   {
  494.     returns TRUE if the pattern found is properly delimited
  495.   }
  496.   BEGIN {Is_A_Token}
  497.     IF (Token_Locn + LENGTH(Token[Indx])) < Len THEN
  498.       Next := COPY (Work_Template,
  499.                   (Token_Locn + (LENGTH(Token[Indx]))), 1)
  500.     ELSE
  501.       Next := '.';
  502.  
  503.     IF Token_Locn > 1 THEN
  504.       BEGIN
  505.         Prior := COPY (Work_Template, Token_Locn - 1, 1);
  506.         Is_A_Token := ((Is_Special_Char(Prior)) AND (Is_Special_Char(Next)));
  507.       END
  508.     ELSE
  509.       IF Token_Locn = 1 THEN
  510.         Is_A_Token := (Is_Special_Char (Next));
  511.   END; {Is_A_Token}
  512.  
  513. {*****************************************************************************}
  514.  
  515.   PROCEDURE Mask_Out (KeyWord : Global_Strg);
  516.   {
  517.     mask out a pattern match ... to enable multi-occurrences
  518.   }
  519.   VAR
  520.     Slot : INTEGER;
  521.  
  522.   BEGIN {Mask_Out}
  523.     DELETE (Work_Template, Token_Locn, LENGTH(Token[Indx]));
  524.     Mask := KeyWord;
  525.     FOR Slot := 1 TO LENGTH(KeyWord) DO
  526.       Mask[Slot] := '\';
  527.     INSERT (Mask, Work_Template, Token_Locn)
  528.   END;  {Mask_Out}
  529.  
  530. {*****************************************************************************}
  531.  
  532.  PROCEDURE Do_Turbo_Extension (VAR Extension : Global_Strg);
  533.  
  534.  BEGIN {Do_Turbo_Extension}
  535.    CASE Indx OF
  536.       1 : Extension := 'Absolute';
  537.       3 : Extension := 'Assign';
  538.       4 : Extension := 'AuxInPtr';
  539.       5 : Extension := 'AuxOutPtr';
  540.       9 : Extension := 'BufLen';
  541.      10 : Extension := 'ClrEol';
  542.      11 : Extension := 'ClrScr';
  543.      13 : Extension := 'ConInPtr';
  544.      14 : Extension := 'ConOutPtr';
  545.      15 : Extension := 'ConstPtr';
  546.      16 : Extension := 'CrtExit';
  547.      17 : Extension := 'CrtInit';
  548.      19 : Extension := 'DelLine';
  549.      21 : Extension := 'Execute';
  550.      23 : Extension := 'FilePos';
  551.      24 : Extension := 'FileSize';
  552.      25 : Extension := 'FillChar';
  553.      27 : Extension := 'FreeMem';
  554.      29 : Extension := 'GetMem';
  555.      30 : Extension := 'GotoXY';
  556.      31 : Extension := 'GraphBackGround';
  557.      32 : Extension := 'GraphColorMode';
  558.      33 : Extension := 'GraphMode';
  559.      34 : Extension := 'GraphWindow';
  560.      35 : Extension := 'HeapStr';
  561.      36 : Extension := 'HiResColor';
  562.      37 : Extension := 'InLine';
  563.      39 : Extension := 'InsLine';
  564.      41 : Extension := 'IOResult';
  565.      42 : Extension := 'KeyPressed';
  566.      44 : Extension := 'LongFilePos';
  567.      45 : Extension := 'LongFileSize';
  568.      46 : Extension := 'LongSeek';
  569.      47 : Extension := 'LowVideo';
  570.      48 : Extension := 'LstOutPtr';
  571.      49 : Extension := 'MaxAvail';
  572.      52 : Extension := 'NormVideo';
  573.      53 : Extension := 'NoSound';
  574.      56 : Extension := 'Palette';
  575.      59 : Extension := 'Randomize';
  576.      60 : Extension := 'Random';
  577.      64 : Extension := 'Rename';
  578.      69 : Extension := 'TextBackGround';
  579.      70 : Extension := 'TextColor';
  580.      71 : Extension := 'TextMode';
  581.      72 : Extension := 'UpCase';
  582.      73 : Extension := 'UsrInPtr';
  583.      74 : Extension := 'UsrOutPtr';
  584.      75 : Extension := 'WhereX';
  585.      76 : Extension := 'WhereY';
  586.      77 : Extension := 'Window';
  587.      81 : Extension := 'Chain';
  588.      84 : Extension := 'Delay';
  589.      85 : Extension := 'Erase';
  590.      87 : Extension := 'Flush';
  591.      88 : Extension := 'HiRes';
  592.      91 : Extension := 'MSDos';
  593.      92 : Extension := 'PortW';
  594.      95 : Extension := 'Sound';
  595.     100 : Extension := 'Addr';
  596.     101 : Extension := 'Byte';
  597.     105 : Extension := 'CSeg';
  598.     106 : Extension := 'Draw';
  599.     107 : Extension := 'DSeg';
  600.     111 : Extension := 'Frac';
  601.     114 : Extension := 'Intr';
  602.     116 : Extension := 'MemW';
  603.     117 : Extension := 'Move';
  604.     118 : Extension := 'Plot';
  605.     119 : Extension := 'Port';
  606.     123 : Extension := 'Seek';
  607.     124 : Extension := 'Sqrt';
  608.     125 : Extension := 'SSeg';
  609.     127 : Extension := 'Swap';
  610.     134 : Extension := 'Aux';
  611.     136 : Extension := 'Con';
  612.     144 : Extension := 'Kbd';
  613.     145 : Extension := 'Lst';
  614.     146 : Extension := 'Mem';
  615.     152 : Extension := 'Ofs';
  616.     155 : Extension := 'Ptr';
  617.     156 : Extension := 'Seg';
  618.     158 : Extension := 'ShL';
  619.     159 : Extension := 'ShR';
  620.     163 : Extension := 'Trm';
  621.     164 : Extension := 'Usr';
  622.     167 : Extension := 'XOr';
  623.     169 : Extension := 'Hi';
  624.     173 : Extension := 'Lo';
  625.     176 : Extension := 'Pi';
  626.    END; {CASE Indx OF}
  627.  END;  {Do_Turbo_Extension}
  628.  
  629. {*****************************************************************************}
  630.  
  631.    PROCEDURE Do_Reserved_Word;
  632.  
  633.    BEGIN
  634.      Temp := Token [Indx];
  635.      DELETE (IO_Template, Token_Locn, LENGTH(Token[Indx]));
  636.      IF Res_Case = Lower THEN
  637.        Lo_Strg (Temp);
  638.      IF Borland_Convention THEN
  639.        Do_Turbo_Extension (Temp);
  640.      INSERT (Temp, IO_Template, Token_Locn);
  641.    END;
  642.  
  643. {*****************************************************************************}
  644.  
  645.    PROCEDURE TableSearch;
  646.  
  647.    BEGIN
  648.      Indx := 1;
  649.      REPEAT
  650.        Token_Locn := POS (Token[Indx], Work_Template);
  651.        IF (Token_Locn <> 0) AND Is_A_Token THEN
  652.          BEGIN                    {pattern match is reserved word}
  653.            IF Res_Case <> AsIs THEN
  654.              Do_Reserved_Word;
  655.            Mask_Out (Token[Indx]);
  656.            TableSearch            {recurse!!!}
  657.          END;
  658.        IF Token_Locn <> 0 THEN    {pattern match NOT reserved}
  659.          Mask_Out (Token[Indx]);
  660.        IF Token_Locn = 0 THEN     {no pattern match}
  661.          Indx := Indx + 1;
  662.      UNTIL ( (Indx > Array_Size) AND (Token_Locn = 0) );
  663.    END;
  664.  
  665. {*****************************************************************************}
  666.  
  667.    PROCEDURE Find_Token_Match;
  668.  
  669.    BEGIN {Find_Token_Match}
  670.      REPEAT      {exhaust all keyword occurrences in a line of text}
  671.        TableSearch;
  672.        IF Interruptable THEN
  673.          IF KeyPressed THEN
  674.            BEGIN
  675.              TextColor (24); TextBackGround (1);
  676.              WRITELN;
  677.              WRITE ('Abort pFORMAT of ',In_File_Name,'? ');
  678.              IF User_Says_YES THEN
  679.                User_Quits
  680.              ELSE
  681.                DelLine;
  682.              LowVideo;
  683.            END;
  684.      UNTIL Token_Locn = 0;
  685.    END;  {Find_Token_Match}
  686.  
  687. {*****************************************************************************}
  688.  
  689.   PROCEDURE Fix_Comment_Strings;
  690.   {
  691.     mask out comments & strings so as-is chars can be restored from
  692.     Temp_String onto IO_Template
  693.   }
  694.  
  695.     PROCEDURE Mask_String (Len_Comment : INTEGER);
  696.  
  697.     VAR
  698.       Slot : INTEGER;
  699.  
  700.     BEGIN
  701.       Temp_String := COPY (Work_Template, Strt, Len_Comment);
  702.       FOR Slot := 1 TO LENGTH(Temp_String) DO
  703.         Temp_String[Slot] := ' ';
  704.       DELETE (Work_Template, Strt, Len_Comment);
  705.       INSERT (Temp_String, Work_Template, Strt);
  706.     END;
  707.  
  708.   BEGIN {Fix_Comment_Strings}
  709.     {do strings}
  710.     REPEAT
  711.       Strt := POS('''', Work_Template);
  712.       IF Strt <> 0 THEN
  713.         Work_Template[Strt] := ' ';
  714.       Endd := POS ('''', Work_Template);
  715.       IF Endd <> 0 THEN
  716.         Work_Template[Endd] := ' ';
  717.       IF ((Endd <> 0) AND (Strt <> 0)) THEN
  718.         Mask_String (Endd - Strt + 1);
  719.     UNTIL ((Endd = 0) OR (Strt = 0));
  720.  
  721.     Strt := POS('{', Work_Template);
  722.     IF Strt = 0 THEN {check again for alternative delimiter}
  723.       Strt := POS ('(*', Work_Template);
  724.  
  725.     Endd := POS('}', Work_Template);
  726.     IF Endd = 0 THEN {check again for alternate delimiter}
  727.       Endd := POS('*)', Work_Template);
  728.  
  729.     IF Strt <> 0 THEN
  730.       Comment_Active := TRUE;
  731.  
  732.     IF Endd <> 0 THEN
  733.       Comment_Active := FALSE;
  734.  
  735.     IF Strt = 0 THEN
  736.       IF Endd = 0 THEN
  737.         IF Comment_Active THEN
  738.           BEGIN
  739.             Strt := 1;
  740.             Mask_String (Len - Strt + 1)
  741.           END
  742.         ELSE {no active comment}
  743.           BEGIN
  744.             {do nothing}
  745.           END
  746.       ELSE  {endd <> 0}
  747.         BEGIN
  748.           Strt := 1;
  749.           Mask_String (Endd - Strt + 1)
  750.         END
  751.     ELSE    {strt <> 0}
  752.       IF Endd <> 0 THEN
  753.         Mask_String (Endd - Strt + 1)
  754.       ELSE
  755.         Mask_String (Len - Strt + 1);
  756.   END; {Fix_Comment_Strings}
  757.  
  758. {*****************************************************************************}
  759.  
  760.   PROCEDURE Parse;
  761.  
  762.   VAR
  763.     Slot : INTEGER;
  764.  
  765.   BEGIN
  766.     Work_Template := IO_Template;
  767.     Len := LENGTH (IO_Template);
  768.  
  769.     Fix_Comment_Strings;
  770.  
  771.     Up_Strg (Work_Template);
  772.  
  773.     Temp_String := IO_Template;
  774.  
  775.     IF Non_Res_Case = Upper THEN
  776.       Up_Strg (IO_Template)
  777.     ELSE
  778.       IF Non_Res_Case = Lower THEN
  779.         Lo_Strg (IO_Template);
  780.  
  781.     FOR Slot := 1 TO LENGTH(IO_Template) DO
  782.       IF Work_Template[Slot] = ' ' THEN
  783.         IO_Template[Slot] := Temp_String[Slot];
  784.  
  785.     Find_Token_Match;
  786.   END;
  787.  
  788. {*****************************************************************************}
  789.  
  790.   PROCEDURE Verify_Default_Settings;
  791.  
  792.   BEGIN
  793.     GotoXY (1,3);
  794.     WRITELN;
  795.     TextColor (1); TextBackGround (1);
  796.     WRITELN ('Output File ',Out_File_Name,'''','s default attributes are :');
  797.     LowVideo;
  798.     WRITELN (' ■ TurboPASCAL key/reserved words are in UPPER-case letters and');
  799.     WRITELN (' ■ Other alphabetic characters are written as is.');
  800.     WRITELN;
  801.     WRITE   ('Would you like to change these defaults ? ');
  802.     IF User_Says_YES THEN
  803.       Change_Defaults
  804.     ELSE
  805.       BEGIN
  806.         Res_Case := Upper;
  807.         Non_Res_Case := Lower;
  808.       END;
  809.   END;
  810.  
  811. {*****************************************************************************}
  812.  
  813.   PROCEDURE Banner;
  814.  
  815.   BEGIN
  816.     ClrScr;
  817.     TextColor (8); TextBackGround (7);
  818.     WRITELN (
  819.   '                  Turbo Format [1.01] - @ndyjsdecepid@ 1984 Nov 16              '
  820.             );
  821.   END;
  822.  
  823. {*****************************************************************************}
  824.  
  825.   PROCEDURE Get_Input_Name;
  826.  
  827.   BEGIN {Get_Input_Name}
  828.     REPEAT
  829.       WRITELN;
  830.       WRITE  ('Name of TurboPASCAL source text file  » ');
  831.       READLN (In_File_Name);
  832.       Trim_Off (In_File_Name);
  833.       Up_Strg (In_File_Name);
  834.  
  835.       IF LENGTH(In_File_Name) < 1 THEN
  836.         User_Quits;
  837.  
  838.       ASSIGN (Text_File, In_File_Name);
  839.       {$I-} RESET (Text_File) {$I+};
  840.       Ok := (IOResult = 0);
  841.       IF NOT Ok THEN
  842.         BEGIN
  843.           Sound (6099);
  844.           Delay (500);
  845.           Sound (600);
  846.           NoSound;
  847.           WRITE ('Cannot find file ');
  848.           NormVideo;
  849.           WRITE (In_File_Name);
  850.           LowVideo;
  851.         END
  852.     UNTIL Ok;
  853.   END; {Get_Input_Name}
  854.  
  855. {*****************************************************************************}
  856.  
  857.   PROCEDURE Get_Output_Name;
  858.  
  859.   BEGIN {Get_Output_Name};
  860.     REPEAT
  861.       WRITELN;
  862.       WRITE  ('Name of pFORMAT generated file        » ');
  863.       READLN (Out_File_Name);
  864.       Trim_Off (Out_File_Name);
  865.       Up_Strg (Out_File_Name);
  866.  
  867.       IF LENGTH (Out_File_Name) < 1 THEN
  868.         User_Quits;
  869.  
  870.       ASSIGN  (Pretty_Output, Out_File_Name);
  871.       {$I-} REWRITE (Pretty_Output) {$I+};
  872.  
  873.       Ok := (IOResult = 0);
  874.  
  875.       IF NOT Ok THEN
  876.         BEGIN
  877.           WRITELN;
  878.           Sound (6099);
  879.           Delay (500);
  880.           Sound (600);
  881.           NoSound;
  882.           WRITE ('Unable to open file ');
  883.           NormVideo;
  884.           WRITE (Out_File_Name);
  885.           LowVideo;
  886.         END;
  887.     UNTIL Ok;
  888.   END; {Get_Input_Name}
  889.  
  890. {*****************************************************************************}
  891.  
  892. BEGIN {--------------------------------------------------------------- pFormat}
  893.   Init_Array;
  894.  
  895.   REPEAT
  896.     Window (1, 1, 80, 25);
  897.     GotoXY (1,1);
  898.     ClrScr;
  899.     Borland_Convention := FALSE;
  900.     Comment_Active     := FALSE;
  901.  
  902.     Banner;
  903.  
  904.     Window (1, 2, 80, 24);
  905.     ClrScr;
  906.     LowVideo;
  907.     WRITELN;
  908.     WRITE   ('■ To quit, press a lone ',CHR(17),'┘ in response to the prompts');
  909.     WRITELN (' for file names.');
  910.     WRITELN;
  911.  
  912.     Get_Input_Name;
  913.     Get_Output_Name;
  914.  
  915.     Window (1, 1, 80, 24);
  916.     GotoXY (1,1);
  917.     Banner;
  918.  
  919.     Window (1, 2, 80, 24);
  920.     Verify_Default_Settings;
  921.     NormVideo;
  922.     WRITELN;
  923.     WRITELN;
  924.     WRITE ('Would you like to be able to abort this run with a keypress?');
  925.     Interruptable := User_Says_YES;
  926.     LowVideo;
  927.     Window (1, 1, 80, 24);
  928.     GotoXY (1,1);
  929.     Banner;
  930.  
  931.     GotoXY (1,3);
  932.     TextColor (16); TextBackGround (1);
  933.     Proc_Label := CONCAT ('Reading ',In_File_Name,' & generating ',
  934.                                    Out_File_Name);
  935.  
  936.     IF (LENGTH (Proc_Label) <= 80) THEN {centre if it fits 80-char line}
  937.       WRITE (Proc_Label:((80 + LENGTH(Proc_Label)) DIV 2))
  938.     ELSE
  939.       WRITE (Proc_Label);
  940.     GotoXY (1,5);
  941.     NormVideo;
  942.     FOR Cnt  := 1 TO 80 DO
  943.       WRITE ('═');
  944.  
  945.     LowVideo;
  946.     Window (1, 6, 80, 23);
  947.     ClrScr;
  948.     Set_Cursor (Invisible);
  949.  
  950.     WHILE NOT (EOF(Text_File)) DO
  951.       BEGIN
  952.         READLN  (Text_File, IO_Template);
  953.         Parse;
  954.         WRITELN (IO_Template);
  955.         WRITELN (Pretty_Output, IO_Template);
  956.       END;
  957.     Set_Cursor (Minimum);
  958.     CLOSE (Text_File);
  959.     CLOSE (Pretty_Output);
  960.     ClrScr;
  961.     WRITELN;
  962.     WRITE ('Quit pFORMAT');
  963.   UNTIL User_Says_YES;
  964. END.  {---------------------------------------------------------------pFormat}
  965.